home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlmath.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  12.1 KB  |  463 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlmath.c
  5. * RCS:          $Header: xlmath.c,v 1.5 91/03/24 22:25:12 mayer Exp $
  6. * Description:  xlisp built-in arithmetic functions
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 04:06:29 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlmath.c,v 1.5 91/03/24 22:25:12 mayer Exp $";
  43.  
  44.  
  45. #include "xlisp.h"
  46. #include <math.h>
  47.  
  48. /* external variables */
  49. extern LVAL true;
  50.  
  51. /* forward declarations */
  52. LOCAL FORWARD LVAL unary();    /* NPM: changed this to LOCAL */
  53. LOCAL FORWARD LVAL binary();    /* NPM: changed this to LOCAL */
  54. LOCAL FORWARD LVAL predicate();    /* NPM: changed this to LOCAL */
  55. LOCAL FORWARD LVAL compare();    /* NPM: changed this to LOCAL */
  56.  
  57. /* binary functions */
  58. LVAL xadd()    { return (binary('+')); } /* + */
  59. LVAL xsub()    { return (binary('-')); } /* - */
  60. LVAL xmul()    { return (binary('*')); } /* * */
  61. LVAL xdiv()    { return (binary('/')); } /* / */
  62. LVAL xrem()    { return (binary('%')); } /* rem */
  63. LVAL xmin()    { return (binary('m')); } /* min */
  64. LVAL xmax()    { return (binary('M')); } /* max */
  65. LVAL xexpt()   { return (binary('E')); } /* expt */
  66. LVAL xlogand() { return (binary('&')); } /* logand */
  67. LVAL xlogior() { return (binary('|')); } /* logior */
  68. LVAL xlogxor() { return (binary('^')); } /* logxor */
  69.  
  70. /* xgcd - greatest common divisor */
  71. LVAL xgcd()
  72. {
  73.     FIXTYPE m,n,r;
  74.     LVAL arg;
  75.  
  76.     if (!moreargs())            /* check for identity case */
  77.     return (cvfixnum((FIXTYPE)0));
  78.     arg = xlgafixnum();
  79.     n = getfixnum(arg);
  80.     if (n < (FIXTYPE)0) n = -n;        /* absolute value */
  81.     while (moreargs()) {
  82.     arg = xlgafixnum();
  83.     m = getfixnum(arg);
  84.     if (m < (FIXTYPE)0) m = -m;    /* absolute value */
  85.     for (;;) {            /* euclid's algorithm */
  86.         r = m % n;
  87.         if (r == (FIXTYPE)0)
  88.         break;
  89.         m = n;
  90.         n = r;
  91.     }
  92.     }
  93.     return (cvfixnum(n));
  94. }
  95.  
  96. /* binary - handle binary operations */
  97. LOCAL LVAL binary(fcn)
  98.   int fcn;
  99. {
  100.     FIXTYPE ival,iarg;
  101.     FLOTYPE fval,farg;
  102.     LVAL arg;
  103.     int mode;
  104.  
  105.     /* get the first argument */
  106.     arg = xlgetarg();
  107.  
  108.     /* set the type of the first argument */
  109.     if (fixp(arg)) {
  110.     ival = getfixnum(arg);
  111.     mode = 'I';
  112.     }
  113.     else if (floatp(arg)) {
  114.     fval = getflonum(arg);
  115.     mode = 'F';
  116.     }
  117.     else
  118.     xlerror("bad argument type",arg);
  119.  
  120.     /* treat a single argument as a special case */
  121.     if (!moreargs()) {
  122.     switch (fcn) {
  123.     case '-':
  124.         switch (mode) {
  125.         case 'I':
  126.         ival = -ival;
  127.         break;
  128.         case 'F':
  129.         fval = -fval;
  130.         break;
  131.         }
  132.         break;
  133.     case '/':
  134.         switch (mode) {
  135.         case 'I':
  136.         checkizero(ival);
  137.         ival = 1 / ival;
  138.         break;
  139.         case 'F':
  140.         checkfzero(fval);
  141.         fval = 1.0 / fval;
  142.         break;
  143.         }
  144.     }
  145.     }
  146.  
  147.     /* handle each remaining argument */
  148.     while (moreargs()) {
  149.  
  150.     /* get the next argument */
  151.     arg = xlgetarg();
  152.  
  153.     /* check its type */
  154.     if (fixp(arg)) {
  155.         switch (mode) {
  156.         case 'I':
  157.             iarg = getfixnum(arg);
  158.             break;
  159.         case 'F':
  160.             farg = (FLOTYPE)getfixnum(arg);
  161.         break;
  162.         }
  163.     }
  164.     else if (floatp(arg)) {
  165.         switch (mode) {
  166.         case 'I':
  167.             fval = (FLOTYPE)ival;
  168.         farg = getflonum(arg);
  169.         mode = 'F';
  170.         break;
  171.         case 'F':
  172.             farg = getflonum(arg);
  173.         break;
  174.         }
  175.     }
  176.     else
  177.         xlerror("bad argument type",arg);
  178.  
  179.     /* accumulate the result value */
  180.     switch (mode) {
  181.     case 'I':
  182.         switch (fcn) {
  183.         case '+':    ival += iarg; break;
  184.         case '-':    ival -= iarg; break;
  185.         case '*':    ival *= iarg; break;
  186.         case '/':    checkizero(iarg); ival /= iarg; break;
  187.         case '%':    checkizero(iarg); ival %= iarg; break;
  188.         case 'M':    if (iarg > ival) ival = iarg; break;
  189.         case 'm':    if (iarg < ival) ival = iarg; break;
  190.         case '&':    ival &= iarg; break;
  191.         case '|':    ival |= iarg; break;
  192.         case '^':    ival ^= iarg; break;
  193.         default:    badiop();
  194.         }
  195.         break;
  196.     case 'F':
  197.         switch (fcn) {
  198.         case '+':    fval += farg; break;
  199.         case '-':    fval -= farg; break;
  200.         case '*':    fval *= farg; break;
  201.         case '/':    checkfzero(farg); fval /= farg; break;
  202.         case 'M':    if (farg > fval) fval = farg; break;
  203.         case 'm':    if (farg < fval) fval = farg; break;
  204.         case 'E':    fval = pow(fval,farg); break;
  205.         default:    badfop();
  206.         }
  207.             break;
  208.     }
  209.     }
  210.  
  211.     /* return the result */
  212.     switch (mode) {
  213.     case 'I':    return (cvfixnum(ival));
  214.     case 'F':    return (cvflonum(fval));
  215.     }
  216. }
  217.  
  218. /* checkizero - check for integer division by zero */
  219. LOCAL checkizero(iarg)        /* NPM: changed this to LOCAL at request of jsp@glia.biostr.washington.edu (Jeff Prothero) */
  220.   FIXTYPE iarg;
  221. {
  222.     if (iarg == 0)
  223.     xlfail("division by zero");
  224. }
  225.  
  226. /* checkfzero - check for floating point division by zero */
  227. LOCAL checkfzero(farg)        /* NPM: changed this to LOCAL at request of jsp@glia.biostr.washington.edu (Jeff Prothero) */
  228.   FLOTYPE farg;
  229. {
  230.     if (farg == 0.0)
  231.     xlfail("division by zero");
  232. }
  233.  
  234. /* checkfneg - check for square root of a negative number */
  235. LOCAL checkfneg(farg)        /* NPM: changed this to LOCAL at request of jsp@glia.biostr.washington.edu (Jeff Prothero) */
  236.   FLOTYPE farg;
  237. {
  238.     if (farg < 0.0)
  239.     xlfail("square root of a negative number");
  240. }
  241.  
  242. /* unary functions */
  243. LVAL xlognot() { return (unary('~')); } /* lognot */
  244. LVAL xabs()    { return (unary('A')); } /* abs */
  245. LVAL xadd1()   { return (unary('+')); } /* 1+ */
  246. LVAL xsub1()   { return (unary('-')); } /* 1- */
  247. LVAL xsin()    { return (unary('S')); } /* sin */
  248. LVAL xcos()    { return (unary('C')); } /* cos */
  249. LVAL xtan()    { return (unary('T')); } /* tan */
  250. LVAL xasin()   { return (unary('s')); } /* asin */
  251. LVAL xacos()   { return (unary('c')); } /* acos */
  252. LVAL xatan()   { return (unary('t')); } /* atan */
  253. LVAL xexp()    { return (unary('E')); } /* exp */
  254. LVAL xsqrt()   { return (unary('R')); } /* sqrt */
  255. LVAL xfix()    { return (unary('I')); } /* truncate */
  256. LVAL xfloat()  { return (unary('F')); } /* float */
  257. LVAL xrand()   { return (unary('?')); } /* random */
  258.  
  259. /* unary - handle unary operations */
  260. LOCAL LVAL unary(fcn)
  261.   int fcn;
  262. {
  263.     FLOTYPE fval;
  264.     FIXTYPE ival;
  265.     LVAL arg;
  266.  
  267.     /* get the argument */
  268.     arg = xlgetarg();
  269.     xllastarg();
  270.  
  271.     /* check its type */
  272.     if (fixp(arg)) {
  273.     ival = getfixnum(arg);
  274.     switch (fcn) {
  275.     case '~':    ival = ~ival; break;
  276.     case 'A':    ival = (ival < 0 ? -ival : ival); break;
  277.     case '+':    ival++; break;
  278.     case '-':    ival--; break;
  279.     case 'I':    break;
  280.     case 'F':    return (cvflonum((FLOTYPE)ival));
  281.     case '?':    ival = (FIXTYPE)osrand((int)ival); break;
  282.     default:    badiop();
  283.     }
  284.     return (cvfixnum(ival));
  285.     }
  286.     else if (floatp(arg)) {
  287.     fval = getflonum(arg);
  288.     switch (fcn) {
  289.     case 'A':    fval = (fval < 0.0 ? -fval : fval); break;
  290.     case '+':    fval += 1.0; break;
  291.     case '-':    fval -= 1.0; break;
  292.     case 'S':    fval = sin(fval); break;
  293.     case 'C':    fval = cos(fval); break;
  294.     case 'T':    fval = tan(fval); break;
  295.     case 's':    fval = asin(fval); break;
  296.     case 'c':    fval = acos(fval); break;
  297.     case 't':    fval = atan(fval); break;
  298.     case 'E':    fval = exp(fval); break;
  299.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  300.     case 'I':    return (cvfixnum((FIXTYPE)fval));
  301.     case 'F':    break;
  302.     default:    badfop();
  303.     }
  304.     return (cvflonum(fval));
  305.     }
  306.     else
  307.     xlerror("bad argument type",arg);
  308. }
  309.  
  310. /* unary predicates */
  311. LVAL xminusp() { return (predicate('-')); } /* minusp */
  312. LVAL xzerop()  { return (predicate('Z')); } /* zerop */
  313. LVAL xplusp()  { return (predicate('+')); } /* plusp */
  314. LVAL xevenp()  { return (predicate('E')); } /* evenp */
  315. LVAL xoddp()   { return (predicate('O')); } /* oddp */
  316.  
  317. /* predicate - handle a predicate function */
  318. LOCAL LVAL predicate(fcn)
  319.   int fcn;
  320. {
  321.     FLOTYPE fval;
  322.     FIXTYPE ival;
  323.     LVAL arg;
  324.  
  325.     /* get the argument */
  326.     arg = xlgetarg();
  327.     xllastarg();
  328.  
  329.     /* check the argument type */
  330.     if (fixp(arg)) {
  331.     ival = getfixnum(arg);
  332.     switch (fcn) {
  333.     case '-':    ival = (ival < 0); break;
  334.     case 'Z':    ival = (ival == 0); break;
  335.     case '+':    ival = (ival > 0); break;
  336.     case 'E':    ival = ((ival & 1) == 0); break;
  337.     case 'O':    ival = ((ival & 1) != 0); break;
  338.     default:    badiop();
  339.     }
  340.     }
  341.     else if (floatp(arg)) {
  342.     fval = getflonum(arg);
  343.     switch (fcn) {
  344.     case '-':    ival = (fval < 0); break;
  345.     case 'Z':    ival = (fval == 0); break;
  346.     case '+':    ival = (fval > 0); break;
  347.     default:    badfop();
  348.     }
  349.     }
  350.     else
  351.     xlerror("bad argument type",arg);
  352.  
  353.     /* return the result value */
  354.     return (ival ? true : NIL);
  355. }
  356.  
  357. /* comparison functions */
  358. LVAL xlss() { return (compare('<')); } /* < */
  359. LVAL xleq() { return (compare('L')); } /* <= */
  360. LVAL xequ() { return (compare('=')); } /* = */
  361. LVAL xneq() { return (compare('#')); } /* /= */
  362. LVAL xgeq() { return (compare('G')); } /* >= */
  363. LVAL xgtr() { return (compare('>')); } /* > */
  364.  
  365. /* compare - common compare function */
  366. LOCAL LVAL compare(fcn)
  367.   int fcn;
  368. {
  369.     FIXTYPE icmp,ival,iarg;
  370.     FLOTYPE fcmp,fval,farg;
  371.     LVAL arg;
  372.     int mode;
  373.  
  374.     /* get the first argument */
  375.     arg = xlgetarg();
  376.  
  377.     /* set the type of the first argument */
  378.     if (fixp(arg)) {
  379.     ival = getfixnum(arg);
  380.     mode = 'I';
  381.     }
  382.     else if (floatp(arg)) {
  383.     fval = getflonum(arg);
  384.     mode = 'F';
  385.     }
  386.     else
  387.     xlerror("bad argument type",arg);
  388.  
  389.     /* handle each remaining argument */
  390.     for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
  391.  
  392.     /* get the next argument */
  393.     arg = xlgetarg();
  394.  
  395.     /* check its type */
  396.     if (fixp(arg)) {
  397.         switch (mode) {
  398.         case 'I':
  399.             iarg = getfixnum(arg);
  400.             break;
  401.         case 'F':
  402.             farg = (FLOTYPE)getfixnum(arg);
  403.         break;
  404.         }
  405.     }
  406.     else if (floatp(arg)) {
  407.         switch (mode) {
  408.         case 'I':
  409.             fval = (FLOTYPE)ival;
  410.         farg = getflonum(arg);
  411.         mode = 'F';
  412.         break;
  413.         case 'F':
  414.             farg = getflonum(arg);
  415.         break;
  416.         }
  417.     }
  418.     else
  419.         xlerror("bad argument type",arg);
  420.  
  421.     /* compute result of the compare */
  422.     switch (mode) {
  423.     case 'I':
  424.         icmp = ival - iarg;
  425.         switch (fcn) {
  426.         case '<':    icmp = (icmp < 0); break;
  427.         case 'L':    icmp = (icmp <= 0); break;
  428.         case '=':    icmp = (icmp == 0); break;
  429.         case '#':    icmp = (icmp != 0); break;
  430.         case 'G':    icmp = (icmp >= 0); break;
  431.         case '>':    icmp = (icmp > 0); break;
  432.         }
  433.         break;
  434.     case 'F':
  435.         fcmp = fval - farg;
  436.         switch (fcn) {
  437.         case '<':    icmp = (fcmp < 0.0); break;
  438.         case 'L':    icmp = (fcmp <= 0.0); break;
  439.         case '=':    icmp = (fcmp == 0.0); break;
  440.         case '#':    icmp = (fcmp != 0.0); break;
  441.         case 'G':    icmp = (fcmp >= 0.0); break;
  442.         case '>':    icmp = (fcmp > 0.0); break;
  443.         }
  444.         break;
  445.     }
  446.     }
  447.  
  448.     /* return the result */
  449.     return (icmp ? true : NIL);
  450. }
  451.  
  452. /* badiop - bad integer operation */
  453. LOCAL badiop()
  454. {
  455.     xlfail("bad integer operation");
  456. }
  457.  
  458. /* badfop - bad floating point operation */
  459. LOCAL badfop()
  460. {
  461.     xlfail("bad floating point operation");
  462. }
  463.